home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / debug / event-test.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  7KB  |  234 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (SCL XLIB)); Base: 10 -*-
  2.  
  3. (defstruct event
  4.   key                       ; Event key
  5.   display                   ; Display event was reported to
  6.   ;; The following are from the CLX event
  7.   code
  8.   state
  9.   time
  10.   event-window
  11.   root
  12.   drawable
  13.   window
  14.   child
  15.   parent
  16.   root-x
  17.   root-y
  18.   x
  19.   y
  20.   width
  21.   height
  22.   border-width
  23.   override-redirect-p
  24.   same-screen-p
  25.   configure-p
  26.   hint-p
  27.   kind
  28.   mode
  29.   keymap
  30.   focus-p
  31.   count
  32.   major
  33.   minor
  34.   above-sibling
  35.   place
  36.   atom
  37.   selection
  38.   requestor
  39.   target
  40.   property
  41.   colormap
  42.   new-p
  43.   installed-p
  44.   format
  45.   type
  46.   data
  47.   send-event-p
  48.   )
  49.  
  50. (defun process-input (display &optional timeout)
  51.   "Process one event"
  52.   (declare (type display display)        ; The display (from initialize-clue)
  53.        (type (or null number) timeout)    ; optional timeout in seconds
  54.        (values (or null character)))        ; Returns NIL only if timeout exceeded
  55.   (let ((event (make-event)))
  56.     (setf (event-display event) display)
  57.     (macrolet ((set-event (&rest parameters)
  58.          `(progn ,@(mapcar #'(lambda (parm)
  59.                        `(setf (,(intern (concatenate 'string "EVENT-" (string parm)))
  60.                            event) ,parm))
  61.                    parameters)))
  62.            (dispatch (contact)
  63.           `(dispatch-event event event-key send-event-p ,contact)))
  64.  
  65.       (let ((result
  66.           (xlib:event-case (display :timeout timeout :force-output-p t)
  67.         ((:key-press :key-release :button-press :button-release)
  68.          (code time root window child root-x root-y x y
  69.                state same-screen-p event-key send-event-p)
  70.          (set-event code time root window child root-x root-y x y
  71.                 state same-screen-p)
  72.          (dispatch window))
  73.         
  74.         (:motion-notify
  75.           (hint-p time root window child root-x root-y x y
  76.               state same-screen-p event-key send-event-p)
  77.           (set-event hint-p time root window child root-x root-y x y
  78.                  state same-screen-p)
  79.           (dispatch window))
  80.         
  81.         ((:enter-notify :leave-notify)
  82.          (kind time root window child root-x root-y x y
  83.                state mode focus-p same-screen-p event-key send-event-p)
  84.          (set-event kind time root window child root-x root-y x y
  85.                 state mode focus-p same-screen-p)
  86.          (dispatch window))
  87.         
  88.         ((:focus-in :focus-out)
  89.          (kind window mode event-key send-event-p)
  90.          (set-event kind window mode)
  91.          (dispatch window))
  92.         
  93.         (:keymap-notify
  94.           (window keymap event-key send-event-p)
  95.           (set-event window keymap)
  96.           (dispatch window))
  97.         
  98.         (:exposure
  99.           (window x y width height count event-key send-event-p)
  100.           (set-event window x y width height count)
  101.           (dispatch window))
  102.         
  103.         (:graphics-exposure
  104.           (drawable x y width height count major minor event-key send-event-p)
  105.           (set-event drawable x y width height count major minor)
  106.           (dispatch drawable))
  107.         
  108.         (:no-exposure
  109.           (drawable major minor event-key send-event-p)
  110.           (set-event drawable major minor)
  111.           (dispatch drawable))
  112.         
  113.         (:visibility-notify
  114.           (window state event-key send-event-p)
  115.           (set-event window state)
  116.           (dispatch window))
  117.         
  118.         (:create-notify
  119.           (parent window x y width height border-width
  120.               override-redirect-p event-key send-event-p)
  121.           (set-event parent window x y width height border-width
  122.                  override-redirect-p)
  123.           (dispatch parent))
  124.         
  125.         (:destroy-notify
  126.           (event-window window event-key send-event-p)
  127.           (set-event event-window window)
  128.           (dispatch event-window))
  129.         
  130.         (:unmap-notify
  131.           (event-window window configure-p event-key send-event-p)
  132.           (set-event event-window window configure-p)
  133.           (dispatch event-window))
  134.         
  135.         (:map-notify
  136.           (event-window window override-redirect-p event-key send-event-p)
  137.           (set-event event-window window override-redirect-p)
  138.           (dispatch event-window))
  139.         
  140.         (:map-request
  141.           (parent window event-key send-event-p)
  142.           (set-event parent window)
  143.           (dispatch parent))
  144.         
  145.         (:reparent-notify
  146.           (event-window window parent x y override-redirect-p event-key send-event-p)
  147.           (set-event event-window window parent x y override-redirect-p)
  148.           (dispatch event-window))
  149.         
  150.         (:configure-notify
  151.           (event-window window above-sibling x y width height border-width
  152.                 override-redirect-p event-key send-event-p)
  153.           (set-event event-window window above-sibling x y width height
  154.                  border-width override-redirect-p)
  155.           (dispatch event-window))
  156.         
  157.         (:configure-request
  158.           (parent window above-sibling x y width height border-width event-key send-event-p)
  159.           (set-event parent window above-sibling x y width height border-width)
  160.           (dispatch parent))
  161.         
  162.         (:gravity-notify
  163.           (event-window window x y event-key send-event-p)
  164.           (set-event event-window window x y)
  165.           (dispatch event-window))
  166.         
  167.         (:resize-request
  168.           (window width height event-key send-event-p)
  169.           (set-event window width height)
  170.           (dispatch window))
  171.         
  172.         (:circulate-notify
  173.           (event-window window parent place event-key send-event-p)
  174.           (set-event event-window window parent place)
  175.           (dispatch event-window))
  176.         
  177.         (:circulate-request
  178.           (parent window place event-key send-event-p)
  179.           (set-event parent window place)
  180.           (dispatch parent))
  181.         
  182.         (:property-notify
  183.           (window atom time state event-key send-event-p)
  184.           (set-event window atom time state)
  185.           (dispatch window))
  186.         
  187.         (:selection-clear
  188.           (time window selection event-key send-event-p)
  189.           (set-event time window selection)
  190.           (dispatch window))
  191.         
  192.         (:selection-request
  193.           (time window requestor selection target property event-key send-event-p)
  194.           (set-event time window requestor selection target property)
  195.           (dispatch window))
  196.         
  197.         (:selection-notify
  198.           (time window selection target property event-key send-event-p)
  199.           (set-event time window selection target property)
  200.           (dispatch window))
  201.         
  202.         (:colormap-notify
  203.           (window colormap new-p installed-p event-key send-event-p)
  204.           (set-event window colormap new-p installed-p)
  205.           (dispatch window))
  206.         
  207.         (:client-message
  208.           (format window type data event-key send-event-p)
  209.           (set-event format window type data)
  210.           (dispatch window))
  211.         
  212.         (:mapping-notify
  213.           (request start count)
  214.           (mapping-notify display request start count)) ;; Special case
  215.         )))
  216.     (and result t)))))
  217.  
  218. (defun event-case-test (display)
  219.   ;; Tests universality of display, event-key, event-code, send-event-p and event-window
  220.   (event-case (display)
  221.     ((key-press key-release button-press button-release motion-notify
  222.       enter-notify leave-notify focus-in focus-out keymap-notify
  223.       exposure graphics-exposure no-exposure visibility-notify
  224.       create-notify destroy-notify unmap-notify map-notify map-request
  225.       reparent-notify configure-notify gravity-notify resize-request
  226.       configure-request circulate-notify circulate-request property-notify
  227.       selection-clear selection-request selection-notify colormap-notify client-message)
  228.      (display event-key event-code send-event-p event-window)
  229.      (print (list display event-key event-code send-event-p event-window)))
  230.     (mapping-notify ;; mapping-notify doesn't have event-window
  231.       (display event-key event-code send-event-p)
  232.       (print (list display event-key event-code send-event-p)))
  233.     ))
  234.